(define-library (packrat datatypes)
  (export make-grammar define-grammar grammar? grammar-contents
          make-location location? location-query location-read
          make-result result? result-success? result-failure?
          result-semantics result-residue result-context
          result-deny rtssw)
  (import (scheme base)
          (scheme lazy)
          (srfi 14)
          (packrat helpers))
  (cond-expand
   (chibi (import (chibi match)))
   (chicken (import (matchable)))
   (cyclone (import (cyclone match)))
   (gauche (import (util match)))
   (guile (import (ice-9 match)))
   (mosh (import (match)))
   (sagittarius (import (match)))
   ;; The SRFI has been withdrawn, but anyway you need a Wright-Cartwright-Shinn
   ;; pattern matcher.
   (else (import (srfi 204))))
  (begin

    #|
    | <grammar> :: <record-type
    |   <contents: ((<term> . <def>) ...)>
    | >
    | <term> :: <symbol> that is not _
    | <def> :: (<action> <spec>)
    | <action> :: <procedure <semantics> <semantics>>
    | <spec> :: _
    |         | <token predicate>
    |         | <char>
    |         | <char-set>
    |         | (= <raw>) ; rather then `quote', since it would mess up the semantics.
    |         | <term>
    |         | (<opt> <spec> ...)
    | <token predicate> :: <procedure <token> <bool>>
    | <token> :: <any>
    | <raw> :: <any>
    | <opt> :: ! | & | / | ~ | ? | + | *
    |#
    (define-record-type <grammar>
      (--make-grammar <contents>)
      grammar?
      (<contents> grammar-contents))

    (define test-term
      (lambda (term)
        (unless (symbol? term)
          (error "term but not a symbol"
                 term))
        (unless (not (eq? term '_))
          (error "term but `_'"
                 term))
        #t))

    (define test-action
      (lambda (action)
        (unless (procedure? action)
          (error "action but not a procedure"
                 action))
        #t))

    (define test-spec-in
      (curry (contents spec)
        (match spec
          ('_ ; one arbitrary token
           #t)
          ((? procedure?) ; <token predicate>
           #t)
          ((? char?)
           #t)
          ((? char-set?)
           #t)
          (('= raw)
           #t)
          ((? symbol?) ; <term>
           (unless (assq spec contents)
             (error "specification appearing as a symbol but not an existing term"
                    spec))
           #t)
          ((opt subspecs ...)
           (match opt
             ((or '! '? '+ '*)
              (unless (= (length subspecs) 1)
                (error "oprands of invalid number with 1 expected"
                       subspecs))
              (map (test-spec-in contents) subspecs))
             ((or '& '/ '~)
              (unless (>= (length subspecs) 1)
                (error "oprands of invalid number with at least 1 expected"
                       subspecs))
              (map (test-spec-in contents) subspecs))
             (_
              (error "operator not recognized"
                     opt))))
          (_
           (error "invalid specification"
                  spec)))))

    (define validate-grammar-contents
      (lambda (contents)
        (match contents
          (((terms specs actions) ...)
           (map test-term terms)
           (map (test-spec-in contents) specs)
           (map test-action actions))
          (_
           (error "invalid grammar contents"
                  contents)))
        contents))

    (define make-grammar
      (lambda (contents)
        (--make-grammar (validate-grammar-contents contents))))

    (define-syntax define-grammar
      (syntax-rules ()
        ((_ name
           (term spec action ...)
           ...)
         (define name (make-grammar
           (list (list (quote term) (quasiquote spec) (pipeline action ...))
                 ...))))
        ((_ . thing)
         (syntax-error "ill-formed grammar definition"
                       thing))))

    #|
    | <location> :: <record-type
    |   <parsed: ((<term> . <promise <result>>) ...)>
    |   <read: <promise <result>>>
    | >
    |#
    (define-record-type <location>
      (make-location <contents> <token>)
      location?
      (<contents> location-contents)
      (<token> location-token))

    (define location-query
      (lambda (term location)
        (force (cdr (assq term (location-contents location))))))

    (define location-read
      (lambda (location)
        (force (location-token location))))

    #|
    | <result> :: <record-type
    |   <success?: <bool>>
    |   <semantics: <any>>
    |   <residue: <location>>>
    |#
    (define-record-type <result>
      (make-result <success?> <semantics> <residue> <context>)
      result?
      (<success?> result-success?)
      (<semantics> result-semantics)
      (<residue> result-residue)
      (<context> result-context))

    (define result-failure?
      (lambda (result)
        (not (result-success? result))))

    (define result-deny
      (lambda (result context)
        (make-result #f
          (result-semantics result)
          (result-residue result)
          context)))

    (define rtssw ; result-transform-success-semantics-with
      (curry (action result)
        (if (result-success? result)
            (make-result #t
              (action (result-semantics result))
              (result-residue result)
              (result-context result))
            result)))

  )
)
